home *** CD-ROM | disk | FTP | other *** search
/ CICA 1993 April / CICA MS Windows - April 1993.iso / unzipped / programr / tp / tpwmi2 / resource.pas < prev    next >
Pascal/Delphi Source File  |  1992-08-12  |  7KB  |  222 lines
  1. {RESOURCE STATS
  2.     by Steve Willer of Mark Data Management (Copyright 1992)
  3.     This program is copyright, but you may use any function or whatever in
  4.     this source. The only prohibited thing is the re-releasing of code
  5.     edited by you, with my name still on it. If you're going to do this,
  6.     take my name and company name out and don't re-release the docs. I don't
  7.     want people bugging me about code I didn't write.
  8.     This code shouldn't hurt your system, but I make no guarantees. Since
  9.     this is freeware, you hold your own responsibility for using it and the
  10.     problems that may arrive thus. If there are bugs or suggestions, though,
  11.     by all means contact me.
  12.     If there are any questions as to what's going on in the code or you have
  13.     suggestions, by all means contact me. The info is in the docs as well as
  14.     the 'About' box.
  15.     Since the last revision, I have added both stats to the icon box.
  16.     The top number is the GDI percent and the bottom is USER.}
  17.  
  18. program Resource;
  19.  
  20. {$R Resource.RES}
  21.  
  22. uses WObjects, WinTypes, WinProcs, Strings, Frames;
  23.  
  24. function GetHeapSpaces(Handle:THandle):longint; far; external 'KERNEL';
  25.                     {Undocumented function that DOES work with Win 3.1. I know there
  26.                      is another function for this purpose that is documented, but
  27.                      the call is very ugly.}
  28.  
  29.  
  30.  
  31. type
  32.     TResourceApp = object(TApplication)
  33.         procedure InitMainWindow; virtual;
  34.     end;
  35.  
  36.     PResourceWindow = ^TResourceWindow;
  37.     TResourceWindow = object(TWindow)
  38.         function GetClassName: PChar; virtual;
  39.         procedure SetupWindow; virtual;
  40.         procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  41.         procedure Paint(PaintDC:HDC; var PaintInfo:TPaintStruct); virtual;
  42.         procedure WMDestroy(var Msg:TMessage); virtual wm_First+wm_Destroy;
  43.         procedure About;
  44.         procedure WMQueryOpen(var Msg:TMessage); virtual wm_First+wm_QueryOpen;
  45.         procedure WMSysCommand(var Msg:TMessage); virtual wm_First+wm_SysCommand;
  46.         procedure WMTimer(var Msg:TMessage); virtual wm_First+wm_Timer;
  47.     end;
  48.  
  49. var
  50.     R:TRect;
  51.     PctTxt1:array[0..4] of Char;
  52.   PctTxt2:array[0..4] of Char;
  53.   size:integer;
  54. const
  55.     sc_About=100;
  56.     sc_Options=101;
  57.  
  58. procedure TResourceApp.InitMainWindow;
  59. begin
  60.     MainWindow := New(PResourceWindow, Init(nil, 'Resource Stats'));
  61. end;
  62.  
  63. function TResourceWindow.GetClassName: PChar;
  64. begin
  65.     GetClassName := 'ResourceWindow'
  66. end;
  67.  
  68. procedure TResourceWindow.GetWindowClass(var AWndClass: TWndClass);
  69. begin
  70.     TWindow.GetWindowClass(AWndClass);
  71.     AWndClass.HIcon := 0; {This is a necessary line. It tells Windows to
  72.                                                  leave the iconized window blank, allowing a
  73.                                                  program to draw on it.}
  74. end;
  75.  
  76. procedure TResourceWindow.SetupWindow;
  77. var ResMenu:HMenu;
  78.         T:longint;
  79.         wout:boolean;
  80.     LogicFont:HFont;
  81.     PaintDC:HDC;
  82. begin
  83.     TWindow.SetupWindow;
  84.     if SetTimer(HWindow,20,500,nil)=0 then  {timer set for 1/2 second}
  85.     begin
  86.         MessageBox(HWindow,'Too many timers in use. Cannot load.',
  87.                              'Resource Stats',mb_IconExclamation or mb_OK);
  88.         CloseWindow;
  89.     end;
  90.     UpdateWindow(HWindow);
  91.     ResMenu:=GetSystemMenu(HWindow,false);
  92.     size:=15;
  93.     wout:=true;
  94.   PaintDC:=GetDC(HWindow);
  95.     while wout do
  96.     begin
  97.         LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
  98.         SelectObject(PaintDC,LogicFont);
  99.         If Loword(GetTextExtent(PaintDC,'100%',4))<(GetSystemMetrics(sm_CXIcon)) then wout:=false
  100.         else size:=size-1;
  101.     DeleteObject(LogicFont);
  102.     end;
  103.   ReleaseDC(HWindow,PaintDC);
  104.   if (size*2) > Round(GetSystemMetrics(sm_CYIcon)*0.45) then
  105.       size := Round(GetSystemMetrics(sm_CYIcon)*0.45);
  106. {    EnableMenuItem(ResMenu,sc_Maximize,mf_ByCommand or mf_Grayed or mf_Disabled);
  107.     EnableMenuItem(ResMenu,sc_Restore,mf_ByCommand or mf_Grayed or mf_Disabled);}
  108.     DeleteMenu(ResMenu,sc_Restore,mf_ByCommand);
  109.     DeleteMenu(ResMenu,sc_Maximize,mf_ByCommand);
  110.     AppendMenu(ResMenu,mf_String,0,nil);
  111.     AppendMenu(ResMenu,mf_String,sc_About,'&About Resource Stats...');
  112.     SendMessage(HWindow,wm_Timer,1,0);
  113. end;
  114.  
  115. procedure TResourceWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
  116. var TextMetrics:TTextMetric;
  117.         OldFont,LogicFont:HFont;
  118.     Y1,Y2:integer;
  119. begin
  120.     with R do
  121.     begin
  122.         Right:=GetSystemMetrics(sm_CXIcon)+3;
  123.         Bottom:=GetSystemMetrics(sm_CYIcon)+3;
  124.         Left:=0;Top:=0;
  125.     end;
  126.     DrawBorderFrame(PaintDC,R,true);
  127.  
  128.     LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
  129.   OldFont:=SelectObject(PaintDC,LogicFont);
  130.     SetBkMode(PaintDC,Transparent);
  131.     SetTextAlign(PaintDC,ta_Top);
  132.     GetTextMetrics(PaintDC,TextMetrics);
  133.   Y1:=Round((R.bottom-(2*size))/2)+1;
  134.   Y2:=R.bottom-Y1-size+1;
  135.  
  136.     SetTextColor(PaintDC,RGB(0,0,0));
  137.     TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt1,StrLen(PctTxt1))))/2),
  138.         Y1,PctTxt1,StrLen(PctTxt1));
  139.     SetTextColor(PaintDC,RGB(0,0,0));
  140.     TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt2,StrLen(PctTxt2))))/2),
  141.         Y2,PctTxt2,StrLen(PctTxt2));
  142.  
  143.   SelectObject(PaintDC,OldFont);
  144.     DeleteObject(LogicFont);
  145.     {You may notice that if the window gets uncovered, it doesn't immediately
  146.      redraw itself. The structure of this program dictated that this would be
  147.      an infinite loop, and it didn't seem worth it to rewrite this program,
  148.      considering that the timer is 500ms, anyway...}
  149. end;
  150.  
  151. procedure TResourceWindow.WMTimer(var Msg:TMessage);
  152. var
  153.     wFree,wSize:word;
  154.     GDIPct,UserPct,dwInfo:longint;
  155.   PctTxtT1,PctTxtT2:array[0..4] of char;
  156.     PctNum:string;
  157. begin
  158.     dwInfo:=GetHeapSpaces(GetModuleHandle('GDI'));
  159.     wSize:=HiWord(dwInfo);
  160.     wFree:=LoWord(dwInfo);
  161.     GDIPct:=Round(wFree/wSize*100);
  162.     Str(GDIPct,PctNum);
  163.   PctNum:=PctNum+'%';
  164.   StrPCopy(PctTxtT1,PctNum);
  165.  
  166.     dwInfo:=GetHeapSpaces(GetModuleHandle('User'));
  167.     wSize:=HiWord(dwInfo);
  168.     wFree:=LoWord(dwInfo);
  169.     UserPct:=Round(wFree/wSize*100);
  170.     Str(UserPct,PctNum);
  171.   PctNum:=PctNum+'%';
  172.   StrPCopy(PctTxtT2,PctNum);
  173.  
  174.     if (StrComp(PctTxt1,PctTxtT1)<>0) or (StrComp(PctTxt2,PctTxtT2)<>0) or
  175.           (Msg.wParam=1) then
  176.     begin
  177.         StrPCopy(PctTxt1,PctTxtT1);
  178.     StrPCopy(PctTxt2,PctTxtT2);
  179.         InvalidateRect(HWindow,nil,false);
  180.         UpdateWindow(HWindow);
  181.     end;
  182. end;
  183.  
  184. procedure TResourceWindow.WMQueryOpen(var Msg:TMessage);
  185. begin
  186.     Msg.Result:=0;
  187. end;
  188.  
  189. procedure TResourceWindow.WMDestroy(var Msg:TMessage);
  190. begin
  191.     KillTimer(HWindow,20);
  192.     TWindow.WMDestroy(Msg);
  193. end;
  194.  
  195. procedure TResourceWindow.WMSysCommand(var Msg:TMessage);
  196. begin
  197.     case Msg.wParam of
  198.         sc_About:
  199.                 About  {I was thinking about adding an Options... menu item.}
  200.         else             {That's why this unnecessary Case command is here.}
  201.             DefWndProc(Msg);
  202.     end;
  203. end;
  204.  
  205. procedure TResourceWindow.About;
  206. var Dialog:TDialog;
  207. begin
  208.     Dialog.Init(@Self, 'About');
  209.     Dialog.Execute;
  210.     Dialog.Done;
  211. end;
  212.  
  213. var
  214.     ResourceApp: TResourceApp;
  215.  
  216. begin
  217.     CmdShow:=sw_Minimize;
  218.     ResourceApp.Init('ResourceApp');
  219.     ResourceApp.Run;
  220.     ResourceApp.Done;
  221. end.
  222.